Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue26/pagectrl/PAGECTL3.PAS

Pascal/Delphi Source File | 1997-09-02 | 11.8 KB | 418 lines

//TabSheet's Tag holds the image
//Can't change Tag to alter image for tab
//Change tabsheet's PageIndex, glyph disappears - resizing fixes
//Tabsheet can't draw buttons in bottom or right positions
//Use TColorPageCtrl.TabVisible instead of
//  TTabSheet.TabVisible or TTabSheet.Visible

unit PageCtl3;

interface

uses
  Windows, Messages, CommCtrl, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, ComCtrls, StdCtrls, ExtCtrls;

type
  TTabVPosition = (tvpNone, tvpLeft, tvpRight);
  TPageControlStyle = (pcsStandard, pcsOwnerDraw);

  TColorPageControl = class(TPageControl)
  private
    FCanvas       : TCanvas;
    FImages       : TImageList;
    FOnDrawItem   : TDrawItemEvent;
    FTabButtons   : Boolean;
    FStyle        : TPageControlStyle;
    FTabVPosition : TTabVPosition;

    procedure AddImages;
    procedure DrawItem(Index: Integer; ARect: TRect;
      State: TOwnerDrawState);
    function IsValidTabSheet (iTab: TTabSheet): Boolean;

    function  GetTabImage(iTab: TTabSheet): Integer;
    procedure SetTabImage(iTab: TTabSheet; iImageIndex: Integer);
    procedure ISetTabImage(iTabIndex, iImageIndex: Integer);

    function  GetTabImageVisible(iTab: TTabSheet): Boolean;
    procedure SetTabImageVisible(iTab: TTabSheet; Value: Boolean);

    function  GetTabVisible(iTab: TTabSheet): Boolean;
    procedure SetTabVisible(iTab: TTabSheet; Value: Boolean);

    procedure CMControlListChange(var Msg: TCMControlListChange);
      message cm_ControlListChange;

  protected
    procedure AlignControls(AControl: TControl;
      var Rect: TRect); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;

    procedure SetImages(Value: TImageList);
    procedure SetStyle(Value: TPageControlStyle);
    procedure SetTabButtons(Value: Boolean);
    procedure SetTabVPosition(Value: TTabVPosition);

    procedure CNDrawItem(var Msg: TWMDrawItem);
      message cn_DrawItem;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DefaultDrawTab(Index: Integer; ARect: TRect;
      State: TOwnerDrawState); virtual;
    property Canvas: TCanvas read FCanvas;
    property TabImage[Index: TTabSheet]: Integer
      read GetTabImage write SetTabImage;
    property TabImageVisible[Index: TTabSheet]: Boolean
      read GetTabImageVisible write SetTabImageVisible;
    property TabVisible[Index: TTabSheet]: Boolean
      read GetTabVisible write SetTabVisible;

  published
    property Images: TImageList read FImages write SetImages;
    property Style: TPageControlStyle
      read FStyle write SetStyle default pcsStandard;
    property TabButtons: Boolean
      read FTabButtons write SetTabButtons default False;
    property TabVPosition: TTabVPosition
      read FTabVPosition write SetTabVPosition default tvpNone;
    property OnDrawItem: TDrawItemEvent
      read FOnDrawItem write FOnDrawItem;
  end;

procedure Register;

implementation

//Delphi 2 and C++ Builder 1 don't have some
//of the necessary constants or properties
{$ifdef Ver90}
  {$define OldCommCtrl}
{$endif}
{$ifdef Ver93}
  {$define OldCommCtrl}
{$endif}
{$ifdef OldCommCtrl}
const
  tcs_Right = 2;
  tcs_Bottom = 2;
  tcs_Vertical = $80;
{$endif}

constructor TColorPageControl.Create(AOwner: TComponent);
begin
  inherited;
  FTabButtons   := False;
  FStyle        := pcsStandard;
  FTabVPosition := tvpNone
end;

destructor TColorPageControl.Destroy;
begin
  //cleanup after ourselves
  if Assigned(FCanvas) then
    FCanvas.Free;
  inherited
end;

procedure TColorPageControl.AddImages;
var
  Loop: integer;
begin
  if Images <> nil then
  begin
    for Loop := 0 to PageCount - 1 do
      ISetTabImage(Loop, Pages[Loop].Tag);
    Perform(tcm_SetImageList, 0, Longint(Images.Handle));
  end
  else
    Perform(tcm_SetImageList, 0, 0);
  if csDesigning in ComponentState then
    Change;
end;

procedure TColorPageControl.DrawItem(Index: Integer; ARect: TRect;
  State: TOwnerDrawState);
begin
  if Assigned(FOnDrawItem) then
    FOnDrawItem(Self, Index, ARect, State)
  else
    DefaultDrawTab(Index, ARect, State)
end;

function TColorPageControl.IsValidTabSheet(iTab: TTabSheet): Boolean;
begin
  //Sanity checks
  Result := Assigned(iTab) and (iTab.PageControl = Self);
end;

function TColorPageControl.GetTabImage(iTab: TTabSheet): Integer;
var
  TCItem: TTCItem;
begin
  //return Tab's image's index in the imagelist
  Result := -1;
  if not IsValidTabSheet(iTab) then
    Exit;
  Result := iTab.Tag;
  if Result <> -1 then
  begin
    TCItem.mask := tcif_Image;
    if Perform(tcm_GetItem, iTab.TabIndex,
               Longint(@TCItem)) <> 0 then
      Result   := TCItem.iImage;
    iTab.Tag := Result;
  end;
end;

procedure TColorPageControl.SetTabImage(iTab:TTabSheet;
  iImageIndex: Integer);
begin
  //This checks for safety and sets the tabsheet's associated image
  if IsValidTabSheet(iTab) and iTab.TabVisible then
    ISetTabImage(iTab.TabIndex, iTab.Tag);
end;

procedure TColorPageControl.ISetTabImage(iTabIndex, iImageIndex: Integer);
var
  TCItem: TTCItem;
begin
  //Internal function to set tab image
  //without affecting Tag property
  TCItem.mask := tcif_Image;
  //Fill the structure
  Perform(tcm_GetItem, iTabIndex, Longint(@TCItem));
  //Set the new image index
  TCItem.iImage := iImageIndex;
  Perform(tcm_SetItem, iTabIndex, Longint(@TCItem));
end;

function TColorPageControl.GetTabImageVisible(iTab: TTabSheet): Boolean;
var
  TCItem : TTCItem;
begin
  //Tab images are seen as invisible if a tab hasn't got an image
  Result := False;
  if IsValidTabSheet(iTab) then
  begin
    TCItem.mask := tcif_Image;
    //Fill the structure
    Perform(tcm_GetItem, iTab.TabIndex, Longint(@TCItem));
    Result := TCItem.iImage <> -1
  end
end;

procedure TColorPageControl.SetTabImageVisible(iTab: TTabSheet;
  Value: Boolean);
begin
  //Tab images are made visible by adding them to the tab.
  if IsValidTabSheet(iTab) then
    if Value then
      SetTabImage(iTab, iTab.Tag)
    else
      if TabVisible[iTab] then
        ISetTabImage(iTab.TabIndex, -1)
end;

function TColorPageControl.GetTabVisible (iTab: TTabSheet): Boolean;
begin
  //We have to use these functions to make
  //tabsheets visible and invisible as Tabsheets cannot
  //be made hidden - the VCL merely removes them
  //and their associated images from the tab control
  Result := False;
  if IsValidTabSheet(iTab) then
    Result := iTab.TabVisible;
end;

procedure TColorPageControl.SetTabVisible(iTab: TTabSheet;
  Value: Boolean);
begin
  //This will make a tab visible/invisible as appropriate
  //However if an invisible tab had its image removed
  //This code will add it back in
  if IsValidTabSheet(iTab) then
    if iTab.PageControl = Self then
    begin
      iTab.TabVisible := Value;
      if iTab.TabVisible then
        SetTabImage(iTab, iTab.Tag);
      Realign
    end;
end;

procedure TColorPageControl.CMControlListChange(
  var Msg: TCMControlListChange);
begin
  //Update the images if a new Tabsheet is installed
  with Msg do
    if (Control is TTabSheet) and not Inserting then
      AddImages;
  inherited
end;

procedure TColorPageControl.AlignControls(AControl: TControl;
  var Rect: TRect);
begin
  inherited AlignControls(AControl, Rect);
  if (AControl is TTabSheet) then
    with TTabSheet(AControl) do
    begin
      //Here the TabSheet Tag is set to hold the image index
      Tag := TabIndex;
      ISetTabImage(Tag, Tag);
      if Images <> nil then
        Perform(tcm_SetImageList, 0, Longint(Images.Handle))
    end;
end;

procedure TColorPageControl.CreateParams(var Params: TCreateParams);
const
  ButtonStyle: array[Boolean] of LongInt = (0, tcs_Buttons);
  OwnStyle: array[Boolean] of LongInt = (0, tcs_OwnerDrawFixed);
  VerticalStyle: array[TTabVPosition] of LongInt =
    (0, tcs_Vertical, tcs_Right or tcs_Vertical);
begin
  inherited;
  with Params do
  begin
    if VerticalStyle[FTabVPosition] <> 0 then
      Style := Style and not tcs_Bottom;
    //When ScrollOpposite is set True, buttons don't get drawn
    //Also, the control is unable to do buttons properly
    //When tabs are at bottom or right
    FTabButtons := FTabButtons and not
      {$ifndef OldCommCtrl}
      ScrollOpposite and not
      {$endif}
      ({$ifndef OldCommCtrl}(TabPosition = tpBottom) or {$endif}
       (FTabVPosition = tvpRight));
    Style := Style or ButtonStyle[FTabButtons]
                   or OwnStyle[FStyle = pcsOwnerDraw]
                   or VerticalStyle[FTabVPosition];
   end;
end;

procedure TColorPageControl.CreateWnd;
begin
  inherited;
  AddImages;
  //Force a realign and repositioning of tabsheets
  //this is needed for the new vertical and horizontal styles
  PostMessage(Handle, wm_Size, size_Restored,
    MakeLong(Width, Height));
  Realign
end;

procedure TColorPageControl.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  //Always make sure the linked imagelist's removal is tracked
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = Images) then
    Images := nil
end;

procedure TColorPageControl.SetImages(Value: TImageList);
begin
  if FImages <> Value then
  begin
    FImages := Value;
    //Just in case the Images component is on another form,
    //we need to make sure Delphi tells us when it gets deleted
    if FImages <> nil then
      FImages.FreeNotification(Self);
    AddImages;
  end
end;

procedure TColorPageControl.SetStyle(Value: TPageControlStyle);
begin
  if Value <> FStyle then
  begin
    FStyle := Value;
    RecreateWnd;
  end;
end;

procedure TColorPageControl.SetTabButtons(Value: Boolean);
begin
  if Value <> FTabButtons then
  begin
    FTabButtons := Value;
    //Can't have buttons at bottom or right of control
    //The Windows control can't handle it...
    if Value then
    begin
      if FTabVPosition = tvpRight then
        FTabVPosition := tvpNone;
      {$ifndef OldCommCtrl}
      if TabPosition = tpBottom then
        TabPosition := tpTop;
      {$endif}
    end;
    RecreateWnd;
  end;
end;

procedure TColorPageControl.SetTabVPosition(Value: TTabVPosition);
begin
  if  Value <> FTabVPosition then
  begin
    //When tabs are left/right, they turn into multiline
    //automatically so we'd better set the MultiLine property
    FTabVPosition := Value;
    if Value <> tvpNone then
      MultiLine := True;
    RecreateWnd;
  end;
end;

procedure TColorPageControl.CNDrawItem(var Msg: TWMDrawItem);
var
  State: TOwnerDrawState;
begin
  if not Assigned(FCanvas) then
    FCanvas := TCanvas.Create;
  with Msg.DrawItemStruct^ do
  begin
    //The low byte of ItemState is the bitmap that our set requires
    State := TOwnerDrawState(WordRec(Word(ItemState)).Lo);
    FCanvas.Handle := hDC;
    FCanvas.Font   := Font;
    FCanvas.Brush  := Brush;
    if Integer(itemID) >= 0 then
      DrawItem(itemID, rcItem, State);
    FCanvas.Handle := 0;
  end;
end;

procedure TColorPageControl.DefaultDrawTab(Index: Integer;
  ARect: TRect; State: TOwnerDrawState);
var
  S: String;
  X, Y: Integer;
begin
  //Do a bit of default drawing when the
  //component user is'nt doing it
  FCanvas.FillRect(ARect);
  S := Pages[Index].Caption;
  X := (ARect.Right + ARect.Left - FCanvas.TextWidth(S)) div 2;
  Y := (ARect.Bottom + ARect.Top + 4 - FCanvas.TextHeight(S)) div 2;
  //Active tab has text _slightly_ higher
  if odSelected in State then
    Dec(Y, 3);
  FCanvas.TextOut(X, Y, S);
end;

procedure Register;
begin
  RegisterComponents('Clinic', [TColorPageControl]);
end;

end.